home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / hpkernel.t < prev    next >
Text File  |  1989-06-30  |  14KB  |  333 lines
  1. (herald hpkernel
  2.   (env tsys))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; The procedure big_bang MUST come first in this file.     boot-arg-offset
  28. ;;;  When we enter Big_bang the stack looks as follows:
  29. ;;;              ________________
  30. ;;;              |   debug?      |   not a boot arg
  31. ;;;              |_______________|
  32. ;;;              |      argv     |    Command line argv
  33. ;;;              |_______________|
  34. ;;;              |      argc     |    Command line argc
  35. ;;;              |_______________|
  36. ;;;              |  heap-size    |    Size of the static storage area
  37. ;;;              |_______________|
  38. ;;;              |     heap2     | Base addresss of static
  39. ;;;              |_______________|        storage area
  40. ;;;              |     heap1     |
  41. ;;;              |_______________|
  42. ;;;       SP =>  |  return addr  |
  43. ;;;              |_______________|
  44.  
  45.  
  46. ;++ replace the numbers 1 and 3 below with boot/heap1 and boot/heap-size
  47.  
  48.  
  49. (define (big_bang) 
  50.   (lap (*the-slink* m68-big-bang *boot*)
  51.  
  52.     ;; set up global-constants
  53.     (move .l  (d@static P (static '*the-slink*)) nil-reg)
  54.     (asl .l ($ 2) S0)
  55.     (move .l  S0 (d@nil slink/interrupt-handler))    ; interrupt_xenoid
  56.     (move .l SP A1)  ; save argument pointer we have 6 boot-args
  57.     (move .l ($ (fx+ (fixnum-ashl 6 8) header/general-vector)) (@-r SP))
  58.     (lea (d@r SP 2) A2)                                    ; second arg to boot
  59.     (move .l A2 (d@nil slink/boot-args))                 ; set up boot-args
  60.  
  61.     (move .l (d@static P (static 'm68-big-bang)) P)
  62.     (move .l (d@r P -2) A2)
  63.     (lea (label big-bang-return) TP)
  64. ;;; note that nil-reg is in AN and pointer to boot args in A1
  65.     (jmp (@r A2))                  
  66. big-bang-return
  67.     ;; initialize area,area-frontier and area-limit
  68.     (move .l (d@r A1 4) S0)         ; get address of heap
  69.     (move .l S0 (d@r TASK task/area-begin))          
  70.     (move .l S0 (d@r TASK task/area-frontier))       
  71.     (add .l (d@r A1 12) S0)         ; add size to base
  72.     (move .l S0 (d@r TASK task/area-limit))          
  73.  
  74.     ;; Set up the procedure register P and call boot,
  75.     ;; never to return. (note: arg 2 (*boot-args*) setup above)
  76.     (move .l nil-reg A3)
  77.     (tst .b (d@r A1 24))
  78.     (j= %debug)
  79.     (move .l ($ header/true) A3)
  80. %debug
  81.     (lea (d@r TASK %%task-header-offset) A1)          ; root-process
  82.     (move .l  ($ 4) NARGS)                            ; 3 args
  83.     (move .l  (d@static P (static '*boot*)) P)
  84.     (move .l  (d@r P -2) TP)
  85.     (jmp   (@r TP))))
  86.  
  87. (define (call-fault-handler)
  88.   (lap (signal-handler)
  89.  
  90.     (equate t-interrupt                     (fixnum-ashl 2 2))
  91.     (equate t-virtual-timer                 (fixnum-ashl 20 2))
  92.  
  93.     (move .l ($ t-interrupt) A1)
  94.     (btst ($ 1) (d@r TASK task/critical-count))                   
  95.     (jn= %call-fault)
  96.     (move .l ($ t-virtual-timer) A1)
  97. %call-fault                                
  98.     (lea (d@r SP 6) A2)
  99.     (move .l (d@static P (static 'signal-handler)) P)
  100.     (move .l (d@r P -2) TP)
  101.     (clr .b (d@r TASK task/critical-count))
  102.     (jmp (@r TP))))                                
  103.  
  104.  
  105. ;;;; Low-level exception handling
  106.  
  107. (lap-template (0 0 -1 t stack %fault-frame-handler)
  108. %fault-frame-template
  109.     (bset ($ 6) (d@r task task/critical-count))
  110.     (move .l (d@r SP 4) S0)                    ; fault header
  111.     (asr .l ($ 8) S0)
  112.     (add .l ($ 2) S0)                          ; 2 for header and template
  113.     (asl .l ($ 2) S0)
  114.     (tst .l (d@r SP 12))
  115.     (j= foobar)
  116.     (move .l (d@r SP 12) (index (@r SP) S0))   ; restore hacked top of stack
  117. foobar
  118.     (add .w ($ 16) sp)        ; pop template,header,pointers on stack,hack top
  119.     (move .l (d@r SP (* (+ *pointer-temps* *scratch-temps* 9) 4))
  120.              A1)                           ; context
  121.     (move .l (@r+ SP) (d@r A1 %%df_pc))
  122.     (move .l (@r+ SP) (d@r A1 (fx+ %%df_d0 32)))    ; P
  123.     (move .l (@r+ SP) (d@r A1 (fx+ %%df_d0 36)))    ; A1
  124.     (move .l (@r+ SP) (d@r A1 (fx+ %%df_d0 40)))    ; A2
  125.     (move .l (@r+ SP) (d@r A1 (fx+ %%df_d0 44)))    ; A3
  126.     (move .l (@r+ SP) (d@r A1 (fx+ %%df_d0 48)))    ; AN
  127.     (move .l (@r+ SP) (d@r A1 (fx+ %%df_d0 52)))    ; TP
  128.  
  129.     (move .l ($ -8) S0)
  130. %fault-restore-loop                                  ; restore temps
  131.     (move .l (@r+ SP) (index (@r TASK) S0))
  132.     (add .l ($ 4) S0)
  133.     (cmp .l ($ temp-block-size) S0)          
  134.     (j< %fault-restore-loop)
  135.     (add .w ($ 4) SP)                           ; pop context
  136.     (bclr ($ 6) (d@r task task/critical-count))
  137.     (rts)
  138. %fault-frame-handler
  139.     (move .l nil-reg an)
  140.     (rts))
  141.  
  142. (lap-template (0 0 -1 nil stack handle-foreign-return)
  143. %foreign-return
  144.     (bset ($ 6) (d@r task task/critical-count))
  145.     (add .w ($ 8) sp)                         ; pop template,header
  146.     (move .l (@r+ SP) (d@r TASK task/foreign-call-cont))
  147.     (bclr ($ 6) (d@r task task/critical-count))
  148.     (rts)
  149. handle-foreign-return
  150.     (move .l nil-reg AN)
  151.     (rts))
  152.                  
  153.  
  154. (lap-template (0 0 -1 nil stack handle-enable-return)
  155. %re-enabled
  156.     (add .w ($ 4) sp)                         ; pop return address
  157.     (rts)
  158. handle-enable-return
  159.     (move .l nil-reg AN)
  160.     (rts))
  161.  
  162. (lap-template (0 0 -1 nil stack handle-doing-gc-return)
  163. %doing-gc-return
  164.     (add .w ($ 4) sp)                         ; pop return address
  165.     (rts)
  166. handle-doing-gc-return
  167.     (move .l nil-reg AN)
  168.     (rts))
  169.  
  170. ;;; Interrupts can be deferred.   
  171. ;;; the task/critical count byte has
  172. ;;; bit 7 -- interrupts deferred
  173. ;;; bit 6 -- interrupts ignored
  174. ;;; bit 1 -- quit pending
  175. ;;; bit 0 -- timer interrupt pending
  176.  
  177. (define (interrupt_dispatcher)     
  178.   (lap (signal-handler enable-signals gc_interrupt)
  179.  
  180.     (equate %%fault-sp-offset 12)
  181.     (equate %%df_d0       32)
  182.     (equate %%df_pc       18)
  183.     (equate fault-quit      3)
  184.     (equate fault-interrupt                   2)
  185.     (equate fault-virtual-timer               20)
  186.                                              
  187.     (move .l (d@r SP 4) S5)                       ; get signal code
  188.     (move .l nil-reg AN)                          ; move slink to a-reg
  189.     (move .l (d@r AN slink/current-task) task)    ; restore task
  190.     (btst ($ 6) (d@r task task/critical-count))
  191.     (jn= %ignore-interrupt)
  192.     (move .l (d@r SP 12) AN)                      ; get context
  193.     (cmp .l ($ fault-virtual-timer) S5)             ; is this a timer interrupt?
  194.     (j= %timer)                                   
  195.     (cmp .l ($ fault-interrupt) S5)                   ; is this a ^q?
  196.     (jn= %fault)                                  ; if so ..
  197.     (cmp .l (d@r TASK task/doing-gc?) nil-reg)    ; are we doing gc?
  198.     (jn= %doing-gc)                               ; if not ...
  199.     (tst .l (d@r TASK task/foreign-call-cont))
  200.     (jn= %fault)
  201.     (btst ($ 1) (d@r TASK task/critical-count))   ; is this the second one?                
  202.     (j= %set-interrupt-flag)                      ; if not, defer interrupt
  203.     (bclr ($ 1) (d@r TASK task/critical-count))
  204.     (tst .b (d@r TASK task/critical-count))       ; are interrupts deferred?
  205.     (j= %fault)             
  206. %set-interrupt-flag                      ; if so ...
  207.     (or .b ($ 2) (d@r TASK task/critical-count))  ; set quit bit 
  208.     (jbr %ignore-interrupt)
  209. %timer
  210.     (cmp .l (d@r TASK task/doing-gc?) nil-reg)    ; are we doing gc?
  211.     (jn= %ignore-interrupt)
  212.     (tst .b (d@r TASK task/critical-count))
  213.     (j= %fault) 
  214.     (or .b ($ 1) (d@r TASK task/critical-count))  ; set timer bit 
  215. %ignore-interrupt 
  216.     (pea (label %re-enabled))                     ; re-enable interrupts
  217.     (move .l (d@static p (static 'enable-signals)) p)    ; DON'T CONS!!!
  218.     (move .l (d@r p -2) tp)
  219.     (jmp (@r tp))                                                       
  220.  
  221. %doing-gc
  222.     (pea (label %doing-gc-return))
  223.     (move .l (d@static p (static 'gc_interrupt)) p)   
  224.     (move .l (d@r p -2) tp)
  225.     (jmp (@r tp))                                                       
  226.  
  227.  
  228. ;;; Interrupts should be disabled here.
  229. %fault
  230.     (move .l (d@r task task/foreign-call-cont) S1)
  231.     (j=  %t-code-interrupt)
  232.  
  233.     ;; Interrupted out of foreign code.
  234.     (clr .l (d@r task task/foreign-call-cont))     
  235.     (move .b ($ 1) (d@r AN 4))       ; set ok to return bit in context
  236.     (move .l s1 (@-r sp))            ; push foreign continuation
  237.     (sub .l sp s1)                   ; compute frame size
  238.     (asl .l ($ 6) S1)
  239.     (move .b ($ (fx+ header/fault-frame 128)) S1)
  240.     (move .l s1 (@-r sp))            ; push frame size 
  241.     (pea (label %foreign-return))
  242.     (jbr %fault-done)
  243.                                  
  244. ;;; registers s0=fault-sp  aN=context
  245. %t-code-interrupt                    
  246.     (move .l AN (@-r SP))                  ; save context
  247.     (move .l (d@r AN %%fault-sp-offset) S0)        ; get fault SP in S0
  248.     (move .l S0 A1)                        ; save fault sp
  249.  
  250.     (move .l ($ (fx+ temp-block-size 4)) S2)
  251. %fault-save-loop                              ; save temps and extra p and s
  252.     (move .l (index (d@r TASK -8) S2) (@-r SP))
  253.     (sub .l ($ 4) S2)
  254.     (j>= %fault-save-loop)
  255.                                                                          
  256.     (move .l (d@r AN (fx+ %%df_d0 52)) (@-r SP))        ; TP (a5)
  257.     (move .l (d@r AN (fx+ %%df_d0 48)) (@-r SP))        ; AN (a4)
  258.     (move .l (d@r AN (fx+ %%df_d0 44)) (@-r SP))        ; A3 
  259.     (move .l (d@r AN (fx+ %%df_d0 40)) (@-r SP))        ; A2 
  260.     (move .l (d@r AN (fx+ %%df_d0 36)) (@-r SP))        ; A1 
  261.     (move .l (d@r AN (fx+ %%df_d0 32)) (@-r SP))        ; P  (a0)
  262.     (move .l (d@r AN %%df_pc) S1)
  263.     (move .l S1 (@-r SP))
  264.     (move .l nil-reg AN)                                                                   
  265.     (cmp .l (d@r AN slink/kernel-begin) S1)
  266.     (j< %not-in-kernel)
  267.     (cmp .l (d@r AN slink/kernel-end) S1)
  268.     (j> %not-in-kernel)
  269.     (move .l (@r A1) (@-r SP))             ; save hack top of stack
  270.     (clr .l (@-r SP))                      ; no pointers on top
  271.     (jbr %t-code-done)
  272.  
  273. %not-in-kernel
  274.     (clr .l (@-r SP))                      ; no hacked stack top
  275.  
  276. ;;; find how many pointers on top of stack
  277.     (move .l ($ -4) s1)                    ; pointer slot counter as fixnum
  278.  
  279. %find-last-template-loop
  280.     (add .l ($ 4) s1)                      ; incr # pointer counter
  281.     (move .l (@r+ a1) s2)                  ; load next word
  282.     (cmp .b ($ header/vframe) s2)          ; vframe?
  283.     (j= %found-frame)                         ; .. if so, done looking
  284.  
  285.     (move .w s2 s3)                        ; copy for extend test
  286.     (and .b ($ 3) s3)
  287.     (cmp .b ($ tag/extend) s3)             ; extend?
  288.     (jn=  %find-last-template-loop)        ; .. if not, keep looking
  289.     (move .l s2 a3)                        ; copy extend pointer to fetch tem
  290.     (move .l (d@r a3 -2) s3)               ; fetch template 
  291.     (jpos %find-last-template-loop)        ; .. if high bit is 0, keep looking
  292.  
  293. %found-frame
  294.     (move .l s1 (@-r sp))                  ; push number of pointers on stack
  295. %t-code-done
  296.     (sub .l sp s0)                         ; compute total size of frame
  297.     (asl .l ($ 6) s0)
  298.     (move .b ($ header/fault-frame) s0)
  299.     (move .l s0 (@-r SP))                  ; push fault header
  300.     (pea (label %fault-frame-template))         ; call fault handler
  301.  
  302. %fault-done                                            
  303.     (asl .l ($ 2) S5)
  304.     (move .l s5 a1)                             ; 1st argument is signal code
  305.     (lea (d@r SP 6) a2)                         ; 2nd argument is frame
  306.     (move .l (d@static p (static 'signal-handler)) p)   ; ...
  307.     (move .l (d@r p -2) tp)                     ; ...
  308.     (jmp (@r tp))                               ; ...
  309.  
  310.     ))                           
  311.                     
  312. (define (local-machine)
  313.   (object nil                               
  314.       ((machine-type self)          'hp)
  315.       ((page-size self)             1024)
  316.       ((object-file-type self)      'mo)
  317.       ((information-file-type self) 'mi)
  318.       ((noise-file-type self)       'mn)
  319.       ((print-type-string self)     "Machine")))
  320.  
  321. (define (nan? x) (ignore x) '#f)
  322.  
  323. (define (st_mtime stat-block)
  324.   (+ (ash (mref-16-u stat-block 32) 16) 
  325.      (mref-16-u stat-block 36)))
  326.  
  327. (define-integrable (st_size stat-block)
  328.   (mref-integer stat-block 20))
  329.  
  330.  
  331. (define-integrable (st_mode stat-block)
  332.   (mref-16-u stat-block 8))
  333.